home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / tvdmx.exe / TVDMXREP.PAS < prev    next >
Pascal/Delphi Source File  |  1992-07-16  |  13KB  |  541 lines
  1.  
  2. {■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■}
  3. {                            }
  4. {    tvDMXREP  --tvDMX Data Reporting Objects    }
  5. {    tvDMX     --data editing project        }
  6. {                            }
  7. {    Copyright (c) 1992  Randolph Beck        }
  8. {                P.O. Box  56-0487        }
  9. {                Orlando, FL 32856        }
  10. {                CIS:  72361,753        }
  11. {                            }
  12. {■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■}
  13.  
  14. Unit tvDMXREP;
  15.  
  16. {$V-,X+,B-,R-,I- }
  17.  
  18. interface
  19.  
  20. uses
  21.     Dos, Objects, Drivers, Memory, Views, Dialogs, App, MsgBox,
  22.     RSet, DmxGizma, tvDMX, tvGizma;
  23.  
  24. const
  25.     NewLineStr    :  string [20] =  ^M^J;
  26.     cmPRN_NewPage = cmDMX + 40;
  27.  
  28. type
  29.     PDmxReport    = ^TDmxReport;
  30.     TDmxReport    =  OBJECT (TObject)
  31.     DMX        : PDmxScroller;
  32.     Delimiter    : char;
  33.     LineNums    : boolean;
  34.     CurPos        : integer;
  35.     LeftMargin    : integer;
  36.     RightMargin    : integer;
  37.     PageWidth    : integer;
  38.     PageSize    : integer;
  39.     CurrentPage    : integer;
  40.     CurrentLine    : integer;
  41.     CurrentRecord    : integer;
  42.     MarginHit    : boolean;
  43.     ErrorInfo    : word;
  44.       constructor Init (aDMX : PDmxScroller;  ADelimiter : char;
  45.             ALineNums : boolean;  APageSize,APageWidth : integer);
  46.       procedure PrintCtrl (St : string);
  47.       procedure DoPrint (var Buf;  Count : word);
  48.       procedure GotoPos (Pos : integer);
  49.       procedure Print (var Buf;  Count : word);  VIRTUAL;
  50.       procedure SetupPage;  VIRTUAL;
  51.       procedure EndPage;  VIRTUAL;
  52.       procedure SetupDMX;  VIRTUAL;
  53.       procedure EndDMX;  VIRTUAL;
  54.       procedure SetupLine;  VIRTUAL;
  55.       procedure EndLine;  VIRTUAL;
  56.       function  RecNumStr (RecNum : integer) : string;  VIRTUAL;
  57.       procedure PrintStr (St : string);
  58.       procedure PrintLabels;  VIRTUAL;
  59.       procedure PrintRec;
  60.       procedure PrintRows;
  61.       procedure Run;  VIRTUAL;
  62.     end;
  63.  
  64.  
  65.     PDmxReportFile  = ^TDmxReportFile;
  66.     TDmxReportFile  =  OBJECT (TDmxReport)
  67.     ReportText    : Text;
  68.       constructor Init (aDMX : PDmxScroller;  ADelimiter : char;
  69.             ALineNums : boolean;  APageSize,APageWidth : integer;
  70.             AFilename : FNameStr);
  71.       destructor  Done;  VIRTUAL;
  72.       procedure Print (var Buf;  Count : word);  VIRTUAL;
  73.     end;
  74.  
  75.  
  76.     PDmxReportStream  = ^TDmxReportStream;
  77.     TDmxReportStream  =  OBJECT (TDmxReport)
  78.     Stream        : PStream;
  79.       constructor Init (aDMX : PDmxScroller;  ADelimiter : char;
  80.             ALineNums : boolean;  APageSize,APageWidth : integer;
  81.             AStream : PStream);
  82.       procedure Print (var Buf;  Count : word);  VIRTUAL;
  83.     end;
  84.  
  85.  
  86.   procedure DmxReportBox (ATitle :TTitleStr; Msg :string; Report :PDmxReport);
  87.  
  88.  
  89. implementation
  90.  
  91.   { ══ TDmxReport ════════════════════════════════════════════════════════ }
  92.  
  93.  
  94. constructor TDmxReport.Init (aDMX : PDmxScroller;  ADelimiter : char;
  95.         ALineNums : boolean;  APageSize,APageWidth : integer);
  96. begin
  97.   TObject.Init;
  98.   DMX        := aDMX;
  99.   Delimiter    := ADelimiter;
  100.   LineNums    := ALineNums;
  101.   PageSize    := APageSize;
  102.   PageWidth    := APageWidth;
  103. end;
  104.  
  105.  
  106. procedure TDmxReport.PrintCtrl (St : string);
  107. var  i,j,x : integer;
  108.     procedure IncPos;
  109.     begin
  110.       inc (j);
  111.       If (j <= LeftMargin) or (j >= RightMargin) then
  112.         begin
  113.         Delete (St,i,1);
  114.         Dec (i);
  115.         end;
  116.     end;
  117.     procedure DecPos;
  118.     begin
  119.       dec (j);
  120.       If (j >= LeftMargin) or (j <= RightMargin) then
  121.         begin
  122.         Delete (St,i,1);
  123.         Dec (i);
  124.         end;
  125.     end;
  126. begin
  127.   j := CurPos;
  128.   If (length (St) > 0) then
  129.     begin
  130.     i := 1;
  131.     While (i <= length (St)) do
  132.       begin
  133.       Case St [i] of
  134.     ^H :  DecPos;
  135.     ^I :
  136.           begin
  137.           x := j;
  138.           Repeat inc (x) until (x mod 8 = 0);
  139.           If (j < LeftMargin) or (x > RightMargin) then
  140.             begin
  141.             Delete (St,i,1);
  142.             Dec (i);
  143.             Repeat
  144.               inc (j);
  145.               If (j > LeftMargin) and (j < RightMargin) then
  146.                 begin
  147.                 inc (i);
  148.                 Insert (' ',St,i);
  149.                 end;
  150.             Until (j mod 8 = 0);
  151.             end
  152.            else
  153.             j := x;
  154.           end;
  155.     ^J :
  156.           begin
  157.           inc (CurrentLine);
  158.           end;
  159.     ^L :
  160.       begin
  161.       inc (CurrentPage);
  162.       CurrentLine := 0;
  163.           j := 0;
  164.       end;
  165.     ^M :
  166.           begin
  167.           j := 0;
  168.           If (NewLineStr = ^M) then inc (CurrentLine);
  169.           end;
  170.        else  IncPos;
  171.     end;
  172.       inc (i);
  173.       end;
  174.     If (length (St) > 0) then Print (St [1], length (St));
  175.     CurPos := j;
  176.     end;
  177.   If (Application <> nil) then Application^.Idle;
  178. end;
  179.  
  180.  
  181. procedure TDmxReport.DoPrint (var Buf;  Count : word);
  182. var  i,j : integer;
  183.      x   : integer;
  184.      P   : PCharArray;
  185.      L   : longint;
  186. begin
  187.   If (Count = 0) then Exit;
  188.   P := @Buf;
  189.   L := Count;
  190.   x := CurPos + Count;
  191.   While (CurPos < LeftMargin) and (L > 0) do
  192.     begin
  193.     inc (ptrrec (P).ofs);
  194.     dec (L);
  195.     inc (CurPos);
  196.     end;
  197.   i := x;
  198.   While (i > RightMargin) and (L > 0) do
  199.     begin
  200.     dec (L);
  201.     dec (i);
  202.     MarginHit := TRUE;
  203.     end;
  204.   If (L > 0) then Print (P^, L);
  205.   CurPos := x;
  206. end;
  207.  
  208.  
  209. procedure TDmxReport.GotoPos (Pos : integer);
  210. begin
  211.   While (CurPos < Pos) do PrintCtrl (' ');
  212.   While (CurPos > Pos) do PrintCtrl (^H);
  213. end;
  214.           
  215.  
  216. procedure TDmxReport.Print (var Buf;  Count : word);
  217. begin
  218.   Abstract
  219. end;
  220.  
  221.  
  222. procedure TDmxReport.SetupPage;
  223. begin
  224. end;
  225.  
  226.  
  227. procedure TDmxReport.EndPage;
  228. begin
  229.   PrintCtrl (^L);
  230. end;
  231.  
  232.  
  233. procedure TDmxReport.SetupDMX;
  234. var  i : integer;
  235.      S : string;
  236. begin
  237.   S := RecNumStr (1) + '══';
  238.   If (Delimiter = #0) or (Delimiter >= #127) then
  239.     FillChar (S [1], length (S) - 1, '═')
  240.    else
  241.     FillChar (S [1], length (S), '-');
  242.   If LineNums then PrintStr (S);
  243.   If (DMX^.Limit.X > 0) then For i := 1 to DMX^.Limit.X do PrintStr (S [1]);
  244.   PrintCtrl (NewLineStr);
  245. end;
  246.  
  247.  
  248. procedure TDmxReport.EndDMX;
  249. begin
  250.   SetupDMX;  { print the same divider line }
  251. end;
  252.  
  253.  
  254. procedure TDmxReport.SetupLine;
  255. begin
  256. end;
  257.  
  258.  
  259. procedure TDmxReport.EndLine;
  260. begin
  261.   PrintCtrl (NewLineStr);
  262. end;
  263.  
  264.  
  265. function  TDmxReport.RecNumStr (RecNum : integer) : string;
  266. var  S : string;
  267. begin
  268.   If (CurrentRecord >= DMX^.DataBlockSize div DMX^.RecordSize) then
  269.     RecNumStr := '      '
  270.    else
  271.     begin
  272.     Str (succ (RecNum):5, S);
  273.     RecNumStr := S + ' ';
  274.     end;
  275. end;
  276.  
  277.  
  278. procedure TDmxReport.PrintStr (St : string);
  279. begin
  280.   If (length (St) > 0) then DoPrint (St [1], length (St));
  281. end;
  282.  
  283.  
  284. procedure TDmxReport.PrintLabels;
  285. begin
  286.   If (DMX^.Labels <> nil) then With PDmxLabels (DMX^.Labels)^ do
  287.     begin
  288.     DoPrint (Data^, Len);
  289.     end;
  290. end;
  291.  
  292.  
  293. procedure TDmxReport.PrintRec;
  294. var  i        : integer;
  295.      A        : string;
  296.      fieldrec    : pDMXfieldrec;
  297.      DataRec    : pointer;
  298. begin
  299.   If (CurrentRecord < 0) or (CurrentRecord >= DMX^.DataBlockSize div DMX^.RecordSize) then
  300.     DataRec := nil
  301.    else
  302.     DataRec := DMX^.DataAt (CurrentRecord);
  303.   fieldrec := DMX^.DMXfield1;
  304.   While (fieldrec <> nil) do
  305.     begin
  306.     With fieldrec^ do
  307.       begin
  308.       If (access and accHidden = 0) then
  309.     begin
  310.     If access and accDelimiter <> 0 then
  311.       begin
  312.       If (typecode >= #127) and (Delimiter <> #0) then
  313.         A := Delimiter else A := typecode;
  314.       end
  315.      else
  316.       begin
  317.       If (DataRec = nil) then
  318.         begin
  319.         A [0] := char (length (fieldrec^.template^));
  320.         fillchar (A [1], length (A), ' ');
  321.         end
  322.        else
  323.         A    := FieldString (fieldrec, [], DataRec^);
  324.           For i := 1 to length (A) do
  325.             If (Delimiter <> #0) then
  326.               begin
  327.               If (A [i] = showTRUE) then
  328.                 begin
  329.                 If (showTRUE >= #127) then A [i] := '*';
  330.                 end
  331.               else
  332.               If (A [i] = showFALSE) then
  333.                 begin
  334.                 If (showFALSE >= #127) then A [i] := ' ';
  335.                 end
  336.               else
  337.               If (A [i] = #0) then A [i] := ' '
  338.               else
  339.               If (A [i] < ' ') or (A [i] >= #127) then A [i] := '.';
  340.               end
  341.              else
  342.               If (A [i] in [^H,^I,^J,^L,^M]) then A [i] := '.';
  343.       end;
  344.         PrintStr (A);
  345.     end;